home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Video
/
World of Video.iso
/
gfxprograms
/
viewers
/
pcxaga
/
showpcx.pas
< prev
Wrap
Pascal/Delphi Source File
|
1995-02-13
|
8KB
|
310 lines
Program AmigaPCX;
uses Exec,Graphics,Intuition,AmigaDos,Dos;
type arr=array[0..3600] of byte;
st=string;
var l,f,clas,kod,le,lo,o,hlp: longint;
w,bl,mx,my,x,y: word;
b,bb,col,col1,bpln,pb: byte;
MyScreen: tNewScreen;
MyWindow: tNewWindow;
MyBitMap: tBitmap;
Scr: pScreen;
STitle, WTitle, FontName, name, stng: string;
Win: pWindow;
tFont: tTextAttr;
pt: pointer;
p: ^arr;
ps: ^st;
pim: pintuimessage;
out: boolean;
ch:char;
pf:^tfileinfoblock;
label Crash, Help;
procedure OpenLibraries;
begin
IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library',0));
if IntuitionBase = NIL then writeln( 'Intuition.library could not be opened');
GfxBase := pGfxBase(OpenLibrary('graphics.library',0));
if GfxBase = NIL then writeln( 'Graphics.library could not be opened');
end;
procedure OpenScr;
begin
FontName:='topaz.font'#0;
with tFont do begin
ta_Name:=@FontName[1];
ta_YSize:=8;
ta_Style:= FSF_EXTENDED;
ta_Flags:=Fpf_ROMFONT
end;
STitle:='PCXShow'#0;
With MyScreen do begin
LeftEdge := 0;
TopEdge := 0;
Width := 319;
Height := 255;
Depth := bpln;
DetailPen := 2; { Color for details }
BlockPen := 5; { and for blocks }
ViewModes := 0;
Type_ := CUSTOMSCREEN or SPRITES;
Font := @tFONT; { Use the normal Topaz font }
DefaultTitle := @STitle[1];
Gadgets := NIL; { No gadgets }
CustomBitMap := NIL { No bitmap }
end;
Scr:=OpenScreen(@MyScreen);
if scr=nil then writeln('Can''t open screen');
end;
procedure OpenWin(Tit: string; var pW: pWindow; maxx,maxy: word);
begin
with MyWindow do begin
LeftEdge := 0;
TopEdge := 0;
Width := 319;
Height := 255;
DetailPen := 3;
BlockPen := 1;
if tit='' then Title:=nil else Title:=@tit;
Flags := SMART_REFRESH or { Save window in RAM }
ACTIVATE or { Activate it }
NOCAREREFRESH or
BORDERLESS or
SUPER_BITMAP or
RMBTRAP or
REPORTMOUSE_ ;
IDCMPFlags := CloseWindow_ or MouseButtons or MouseMove;
Type_ := CUSTOMSCREEN; { Put window in custom screen }
FirstGadget := NIL; { No gadgets attached }
CheckMark := NIL; { Same checkmark as usual }
Screen := Scr; { Use our own custom screen }
BitMap := @MyBitMap; { No bitmap }
MinWidth := 300; { Dummies as we can't resize }
MinHeight := 200; { this window }
MaxWidth := 320;
MaxHeight := 256
end;
with MyBitMap do begin
BytesperRow:= maxx div 8;
Rows:=maxy;
Depth:=bpln;
for b:=0 to bpln-1 do Planes[b]:=AllocRaster(maxx,maxy);
end;
InitBitmap(@MyBitMap,bpln,maxx,maxy);
pW := OpenWindow(@MyWindow);
if pW = NIL then WRITELN('CANNOT OPEN WINDOW');
end;
procedure Header;
var hd:arr;
minx,miny: word;
begin
Getmem(pt,1300);GetMem(p,1200);
out:=false;
lo:=lock(name,$F);
if examine(lo,pt) then writeln('OK') else begin writeln('NOK - Chyba pri inicializaci. »»»>>> Bye Bye');halt;end;
pf:=pt;le:=pf^.fib_size;
getmem(p,1264);
f:=Open(name,mode_oldfile);
l:=read_(f,p,128);
hd:=p^;
if hd[0]<>10 then begin writeln('Neni PCX obrazek!');out:=true;end else writeln('Obrazek:',name);
writeln('Velikost:',le,' b');
if hd[2]=1 then writeln('RLE kodovani') else writeln('Bez kodovani');
writeln('Bitu na pixel:',hd[3]);
mx:=256*hd[9]+hd[8]+1;my:=256*hd[11]+hd[10]+1;
minx:=256*hd[5]+hd[4];miny:=256*hd[7]+hd[6];
writeln('Min:',minx,'x',miny);
mx:=256*hd[9]+hd[8]+1;my:=256*hd[11]+hd[10]+1;
writeln('Max:',mx,'x',my);
if (minx>1) or (miny>1) then begin mx:=mx-minx;my:=my-miny;end;
writeln('Rozmery:',mx,'x',my);
writeln('Bitovych rovin:',hd[65]);
bl:=256*hd[67]+hd[66];
writeln('Bytu na linku:',bl);
writeln(#10'* Stiskni RETURN *');
readln;
end;
procedure ShowPCX(RP:pRastPort; po:pointer; x1,y1,x2,y2:word);
var g,gg:byte;
dx,dy:word;
n:longint;
begin {ShowPCX by Petr Ocko © 1994 All rights reserved.}
{ ScreentoFront(Scr);} {Contact: XOCKP01@jms.vse.cz}
{or}
n:=0;dy:=y1; {Sv. Cecha 1130}
asm {Bohumin 1}
movea.l po,a4 {Czech Republic}
end;
repeat
dx:=x1;
repeat
asm
move.b (a4)+,g
end;
if g and $c0=$c0 then begin
asm
move.b (a4)+,gg
end;
SetAPen(RP,gg);
Move_(RP,dx,dy);
dx:=dx+(g and $3f);
Draw(RP,dx,dy);
end else
begin
SetApen(RP,g);
Move_(RP,dx,dy);
dx:=dx+1;
Draw(RP,dx,dy);
end;
until dx>=x2+1;
dy:=dy+1;
until dy=y2;
{Permit;}
end;
procedure Paleta;
var h:arr;
p1,p2,p3,p4:longint;
psc:pointer;
begin
if bpln=8 then pb:=255 else pb:=31;
ScreenToFront(scr);
pt:=AllocMem(1000,memf_chip);
l:=seek_(f,le-256*3,$ffffffff);
l:=read_(f,pt,3*256);
psc:=@scr^.Viewport;
asm
move.l a4,p4
movea.l pt,a4
clr.l d0
clr.l d1
clr.l d2
clr.l d3
clr.l d7
moveq #0,d7
@r:move.b (a4)+,d1
lsr.b #4,d1
move.b (a4)+,d2
lsr.b #4,d2
move.b (a4)+,d3
lsr.b #4,d3
move.l a0,p1
movea.l a6,a5
movea.l psc,a0
move.l d7,d0
movea.l GfxBase,a6
jsr -$120(a6)
movea.l a5,a6
move.l p1,a0
addq.b #1,d7
cmp.b pb,d7
bne @r
move.l p4,a4
end;
l:=seek_(f,128,$ffffffff);
FreeMem_(pt,1000);
end;
procedure DataRead;
begin
Paleta;
for b:=0 to pb do begin
SetAPen(Win^.RPort,b);
RectFill(Win^.RPort,b*2,0,b*2+2,5);
end;
pt:=AllocMem(le-767,memf_chip); {alokace pameti pro buffer}
if pt=nil then begin writeln('Nedostatek pameti!');out:=true;exit;end;
l:=read_(f,pt,le-768);
out:=WBenchToFront;
out:=false;
Forbid;
ShowPCX(Win^.RPort,pt,0,0,mx-1,my-1);
writeln(#7);
unlock(lo);
end;
begin
OpenLibraries;
GetMem(pt,1200);getmem(ps,128);
if ParamCount>0 then begin for bb:=1 to paramcount do name:=name+ParamStr(bb);end else begin
o:=Open('CON:10/100/480/36/Zadej jmeno PCX obrazku:',mode_oldfile);
stng:='ShowPCX v2.1 * Usage: ShowPCX [filename] [OCS] [?]'#10#0;
ps:=@stng[1];
l:=Write_(o,ps,52);
l:=Read_(o,ps,127);
bb:=l;
asm
move.l ps,a4
subq #1,a4
move.b bb,(a4)
sub.b #1,(a4)
move.l a4,ps {prevadeni AMIGA stringu do pascalovskeho}
end;
name:=ps^;
Close_(o);
end;
WriteLn('PCXShow v2.1 © 1994 by Petr Ocko'#10'Contact: Sv. Cecha 1130'#10' 735 81 Bohumin-1'#10' Czech Republic');
WriteLn('E-Mail: XOCKP01@jms.vse.cz');
if name[1]='?' then begin writeln('Usage: ShowPCX [?] [[filename] [OCS]]'#10' OCS - shows picture in 5 bplanes screen');
Readln;
Goto help;
end;
bpln:=8;
for b:=1 to length(name) do begin
if copy(name,b,3)='OCS' then bpln:=5;
end;
if bpln=5 then begin
if copy(name,1,3)='OCS' then name:=copy(name,4,length(name)-3) else
name:=copy(name,1,length(name)-3);
end;
Header;if out then Exit;
OpenScr;
OpenWin('',Win,mx,my);
ScreentoBack(Scr);
ClearScreen(Win^.Rport);
ShowTitle(Scr,false);
WriteLn('PCXShow v2.1 © 1994 by Petr Ocko'#10);
WriteLn(#10'Decrunching ',name,' ...');
DataRead;if out then goto crash;
ScreenToFront(Scr);
FreeSprite(0);out:=false;
With Win^ do begin
repeat
l:=wait(Bitmask(Win^.userport^.mp_sigbit));
pim:=PINTUIMESSAGE(getmsg(userport));
while pim<>nil do begin
FreeSprite(0);
clas:=pim^.class;
kod:=pim^.code;
replymsg(pmessage(pim));
if clas=RIGHTHIT then out:=true;
pim:=pIntuiMessage(getmsg(userport));
end;
until out;
Permit;
end;
Crash:
CloseWindow(Win);
For b:=0 to bpln-1 do FreeRaster(MyBitmap.Planes[b],mx,my);
Close_(f);
CloseScreen(Scr);
closelibrary(pLibrary(GfxBase));
closelibrary(pLibrary(IntuitionBase));
FreeMem_(pt,le-768);
help:
end.